home *** CD-ROM | disk | FTP | other *** search
/ Aminet 28 / Aminet 28 (1998)(GTI - Schatztruhe)[!][Dec 1998].iso / Aminet / dev / lang / fpc09905c.lha / fpc / inc / system.inc < prev    next >
Text File  |  1998-09-21  |  16KB  |  621 lines
  1. {
  2.     $Id: system.inc,v 1.28 1998/08/17 12:24:16 carl Exp $
  3.     This file is part of the Free Pascal Run time library.
  4.     Copyright (c) 1993,97 by the Free Pascal development team
  5.  
  6.     See the file COPYING.FPC, included in this distribution,
  7.     For details about the copyright.
  8.  
  9.     This program is distributed in the hope that it will be useful,
  10.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  11.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12.  
  13.  **********************************************************************}
  14.  
  15. {****************************************************************************
  16.                                 Local types
  17. ****************************************************************************}
  18.  
  19. {
  20.   TextRec and FileRec are put in a separate file to make it available to other
  21.   units without putting it explicitly in systemh.
  22.   This way we keep TP compatibility, and the TextRec definition is available
  23.   for everyone who needs it.
  24. }
  25. {$i filerec.inc}
  26. {$i textrec.inc}
  27.  
  28. Procedure HandleError (Errno : Longint); forward;
  29.  
  30. type
  31.   FileFunc = Procedure(var t : TextRec);
  32.  
  33. const
  34. { Random / Randomize constants }
  35.   OldRandSeed : Longint = 0;
  36.   InitialSeed : Boolean = TRUE;
  37.   Seed1 : Longint = 0;
  38.   Seed2 : Longint = 0;
  39.   Seed3 : Longint = 0;
  40.  
  41. { For Error Handling.}
  42.   DoError   : Boolean = FALSE;
  43.   ErrorBase : Longint = 0;
  44.  
  45. {****************************************************************************
  46.                     Include processor specific routines
  47. ****************************************************************************}
  48.  
  49. {$IFDEF I386}
  50.   {$IFDEF M68K}
  51.     {$Error Can't determine processor type !}
  52.   {$ENDIF}
  53.   {$I i386.inc}  { Case dependent, don't change }
  54. {$ELSE}
  55.   {$IFDEF M68K}
  56.     {$I m68k.inc}  { Case dependent, don't change }
  57.   {$ELSE}
  58.     {$Error Can't determine processor type !}
  59.   {$ENDIF}
  60. {$ENDIF}
  61.  
  62. {****************************************************************************
  63.                      Routines which have compiler magic
  64. ****************************************************************************}
  65.  
  66. {$I innr.inc}
  67.  
  68. Function  lo(i : Integer) : byte;  [INTERNPROC: In_lo_Word];
  69. Function  lo(w : Word) : byte;     [INTERNPROC: In_lo_Word];
  70. Function  lo(l : Longint) : Word;  [INTERNPROC: In_lo_long];
  71. Function  hi(i : Integer) : byte;  [INTERNPROC: In_hi_Word];
  72. Function  hi(w : Word) : byte;     [INTERNPROC: In_hi_Word];
  73. Function  hi(l : Longint) : Word;  [INTERNPROC: In_hi_long];
  74. {$ifdef VER0_99_5}
  75. Procedure Inc(var i : Cardinal);   [INTERNPROC: In_Inc_DWord];
  76. Procedure Inc(var i : Longint);    [INTERNPROC: In_Inc_DWord];
  77. Procedure Inc(var i : Integer);    [INTERNPROC: In_Inc_Word];
  78. Procedure Inc(var i : Word);       [INTERNPROC: In_Inc_Word];
  79. Procedure Inc(var i : shortint);   [INTERNPROC: In_Inc_byte];
  80. Procedure Inc(var i : byte);       [INTERNPROC: In_Inc_byte];
  81. Procedure Inc(var c : Char);       [INTERNPROC: In_Inc_byte];
  82. Procedure Inc(var p : PChar);      [INTERNPROC: In_Inc_DWord];
  83. Procedure Dec(var i : Cardinal);   [INTERNPROC: In_Dec_DWord];
  84. Procedure Dec(var i : Longint);    [INTERNPROC: In_Dec_DWord];
  85. Procedure Dec(var i : Integer);    [INTERNPROC: In_Dec_Word];
  86. Procedure Dec(var i : Word);       [INTERNPROC: In_Dec_Word];
  87. Procedure Dec(var i : shortint);   [INTERNPROC: In_Dec_byte];
  88. Procedure Dec(var i : byte);       [INTERNPROC: In_Dec_byte];
  89. Procedure Dec(var c : Char);       [INTERNPROC: In_Dec_byte];
  90. Procedure Dec(var p : PChar);      [INTERNPROC: In_Dec_DWord];
  91. {$endif VER0_99_5}
  92.  
  93. Function chr(b : byte) : Char;      [INTERNPROC: In_chr_byte];
  94. Function Length(s : string) : byte; [INTERNPROC: In_Length_string];
  95.  
  96. Procedure Reset(var f : TypedFile);   [INTERNPROC: In_Reset_TypedFile];
  97. Procedure Rewrite(var f : TypedFile); [INTERNPROC: In_Rewrite_TypedFile];
  98.  
  99.  
  100. {****************************************************************************
  101.                                 Set Handling
  102. ****************************************************************************}
  103.  
  104. { Include set support which is processor specific}
  105. {$I set.inc}
  106.  
  107. {****************************************************************************
  108.                   Subroutines for String handling
  109. ****************************************************************************}
  110.  
  111. { Needs to be before RTTI handling }
  112.  
  113. {$i sstrings.inc}
  114.  
  115. {$ifdef UseAnsiStrings}
  116.  
  117. Type
  118.    PLongint = ^Longint;
  119.    PByte = ^Byte;
  120.  
  121. {$i astrings.pp}
  122.  
  123. {$else}
  124.  
  125. { Provide dummy procedures needed for rtti}
  126. Procedure decr_ansi_ref (P : pointer);[Alias : 'DECR_ANSI_REF'];
  127.   begin
  128.   end;
  129.  
  130. Procedure incr_ansi_ref (P : pointer);[Alias : 'INCR_ANSI_REF'];
  131.   begin
  132.   end;
  133.  
  134. {$endif}
  135.  
  136.  
  137. {****************************************************************************
  138.                          Run-Time Type Information (RTTI)
  139. ****************************************************************************}
  140.  
  141. {$ifndef VER0_99_5}
  142.   {$i rtti.inc}
  143. {$endif  VER0_99_5}
  144.  
  145. {****************************************************************************
  146.                                Math Routines
  147. ****************************************************************************}
  148.  
  149. {$ifndef RTLLITE}
  150.  
  151. function Hi(b : byte): byte;
  152. begin
  153.    Hi := b shr 4
  154. end;
  155.  
  156. function Lo(b : byte): byte;
  157. begin
  158.    Lo := b and $0f
  159. end;
  160.  
  161. {$ifdef VER0_99_5}
  162.  
  163. Procedure Inc(var i : Cardinal;a: Longint);
  164. Begin
  165.   I:=I+A;
  166. End;
  167.  
  168. Procedure Dec(var i : Cardinal;a: Longint);
  169. Begin
  170.   I:=I-A;
  171. End;
  172.  
  173. Procedure Inc(var i : Longint;a : Longint);
  174. Begin
  175.   i:=i+a;
  176. End;
  177.  
  178. Procedure Dec(var i : Longint;a : Longint);
  179. Begin
  180.   i:=i-a;
  181. End;
  182.  
  183. Procedure Dec(var i : Word;a : Longint);
  184. Begin
  185.   i:=i-a;
  186. End;
  187.  
  188. Procedure Inc(var i : Word;a : Longint);
  189. Begin
  190.   i:=i+a;
  191. End;
  192.  
  193. Procedure Dec(var i : Integer;a : Longint);
  194. Begin
  195.   i:=i-a;
  196. End;
  197.  
  198. Procedure Inc(var i : Integer;a : Longint);
  199. Begin
  200.   i:=i+a;
  201. End;
  202.  
  203. Procedure Dec(var i : byte;a : Longint);
  204. Begin
  205.   i:=i-a;
  206. End;
  207.  
  208. Procedure Inc(var i : byte;a : Longint);
  209. Begin
  210.   i:=i+a;
  211. End;
  212.  
  213. Procedure Dec(var i : shortint;a : Longint);
  214. Begin
  215.   i:=i-a;
  216. End;
  217.  
  218. Procedure Inc(var i : shortint;a : Longint);
  219. Begin
  220.   i:=i+a;
  221. End;
  222.  
  223. Procedure Dec(var c : Char;a : Longint);
  224. Begin
  225.   byte(c):=byte(c)-a;
  226. End;
  227.  
  228. Procedure Inc(var c : Char;a : Longint);
  229. Begin
  230.   Byte(c):=byte(c)+a;
  231. End;
  232.  
  233. Procedure Dec(var p : PChar;a : Longint);
  234. Begin
  235.   longint(p):=longint(p)-a;
  236. End;
  237.  
  238. Procedure Inc(var p : PChar;a : Longint);
  239. Begin
  240.   longint(p):=longint(p)+a;
  241. End;
  242.  
  243. {$endif VER0_99_5}
  244.  
  245. Function swap (X : Word) : Word;
  246. Begin
  247.   swap:=(X and $ff) shl 8 + (X shr 8)
  248. End;
  249.  
  250. Function Swap (X : Integer) : Integer;
  251. Begin
  252.   Swap:=Integer(Swap(Word(X)));
  253. End;
  254.  
  255. Function swap (X : Longint) : Longint;
  256. Begin
  257.   Swap:=(X and $ffff) shl 16 + (X shr 16)
  258. End;
  259.  
  260. Function Swap (X : Cardinal) : Cardinal;
  261. Begin
  262.   Swap:=Swap(Longint(X));
  263. End;
  264.  
  265. {$endif RTLLITE}
  266.  
  267. {****************************************************************************
  268.                           Random function routines
  269.                   
  270.     This implements a very long cycle random number generator by combining
  271.    three independant generators.  The technique was described in the March
  272.    1987 issue of Byte.
  273.    Taken and modified with permission from the PCQ Pascal rtl code.
  274. ****************************************************************************}
  275.  
  276. {$R-}
  277. {$Q-}
  278.  
  279. Procedure UseSeed(seed : Longint);Forward;
  280.  
  281.  
  282. Function Random : Real;
  283. var
  284.     ReturnValue : Real;
  285. begin
  286.     if (InitialSeed) OR ((RandSeed <> OldRandSeed) AND NOT InitialSeed) then
  287.     Begin
  288.        OldRandSeed:=RandSeed;
  289.     { This is a pretty complicated affair                             }
  290.     {  Initially we must call UseSeed when RandSeed is initalized     }
  291.     {  We must also call UseSeed each time RandSeed is reinitialized  }
  292.     {  DO NOT CHANGE THE ORDER OF DECLARATIONS IN THIS BLOCK          }
  293.     {  UNLESS YOU WANT RANDON TO CRASH OF COURSE (CEC)                }
  294.       InitialSeed:=FALSE;
  295.       UseSeed(Randseed);
  296.     end;
  297.     Inc(Seed1);
  298.     Seed1 := (Seed1 * 706) mod 500009;
  299.     INC(Seed2);
  300.     Seed2 := (Seed2 * 774) MOD 600011;
  301.     INC(Seed3);
  302.     Seed3 := (Seed3 * 871) MOD 765241;
  303.     ReturnValue := Seed1/500009.0 +
  304.             Seed2/600011.0 +
  305.            Seed3/765241.0;
  306.     Random := frac(ReturnValue);
  307. end;
  308.  
  309.  
  310. Function Random(l : Longint) : Longint;
  311. begin
  312.